home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: MegaDisc
/
MegaDisc 28 (1992-05)(MegaDisc Digital Publishing)(AU)(Disk 2 of 2).zip
/
MegaDisc 28 (1992-05)(MegaDisc Digital Publishing)(AU)(Disk 2 of 2).adf
/
Programming
/
BASIC_TUTORIAL_9
/
diskfont.bas
< prev
next >
Wrap
BASIC Source File
|
1992-05-26
|
15KB
|
490 lines
'BASIC for the Amiga
'Chapter Nine Diskfont.bas
'Purpose - How to Get a Disk Font and use it
'Commands - LIBRARY, DECLARE FUNCTION, LIBRARY CLOSE
' LOCATE, PRINT, FOR...NEXT, INPUT, END
' - OpenFont, CloseFont, AskSetStyle, SetStyle
' - SetFont, enable, pFont
'SUB PROGRAMS - Font, SetStyle
'Author - Frank Wilkinson
LIBRARY "diskfont.library"
LIBRARY "graphics.library"
DECLARE FUNCTION OpenDiskFont& LIBRARY
DECLARE FUNCTION OpenFont& LIBRARY
DECLARE FUNCTION AskSoftStyle& LIBRARY
SCREEN 1,640,256,3,2
WINDOW 2,"DiskFonts",,,1
FOR q = 0 TO 7
READ r,g,b
PALETTE q,r/16,g/16,b/16
NEXT q
DATA 0,0,0, 0,1,12, 7,0,0, 0,7,0, 5,5,0, 5,5,9, 8,0,15, 7,7,7
CLS
LOCATE 2,1
a$(1)="Emerald":a$(2)="Diamond":a$(3)="Ruby":a$(4)="Sapphire"
a$(5)="Garnet":a$(6)="Topaz":count=0
FOR x=1 TO 6
Font a$(x)+".font",19,0,0
GOSUB FontFound
NEXT x
PRINT count
IF count=6 THEN
PRINT "You have all the Fonts in the Fonts Drawer. "
END IF
GOSUB PageTurn
CLS
GOTO Demo
FontFound:
IF pfont&<>0 THEN
Font "topaz.font",8,0,0
PRINT a$(x)".font found"
count=count+1
ELSE
Font "topaz.font",8,0,0
PRINT a$(x)".font not found"
END IF
RETURN
GOSUB PageTurn
Demo: ' Demonstration of Font Command
LOCATE 4,1
Font "Sapphire.font", 19,0,0
enable%=AskSoftStyle&(WINDOW(8))
SetStyle 2
LOCATE 2,12:COLOR 5,0
PRINT "Basic Tutorial"
Font "Sapphire.font",14,0,0
COLOR 4,0
PRINT " Chapter 9"
PRINT " by"
PRINT " Frank Wilkinson"
COLOR 1,0
Font "topaz.font",8,0,0
LOCATE 15,1
PRINT " Demonstration of how to obtain"
PRINT " and use"
PRINT " the FONTS on your System Disk"
GOSUB PageTurn
CLS
Font "Sapphire.font", 19,0,0
SetStyle 3
PRINT:PRINT:COLOR 3,0
PRINT "This is Sapphire 19 Points, Bold and Underlined"
PRINT "Each line of this Font occupies 19 Screen lines."
FOR de=1 TO 1000:NEXT de
Font "Diamond.font", 20,0,0
COLOR 4,0
PRINT "...another TextFont... Diamond 20"
PRINT "This Font occupies 20 Screen lines."
FOR de=1 TO 1000:NEXT de
Font "Emerald.font", 20,0,0
COLOR 3,0
PRINT "...and yet another! Amiga has still more!"
PRINT "Emerald 20 occupies 20 Screen lines."
FOR de=1 TO 1000:NEXT de
Font "RUBY.font", 15,0,0
COLOR 2,0
PRINT "This is RUBY and it occupies 15 screen lines."
FOR de=1 TO 1000:NEXT de
Font "Garnet.font", 16,0,0
PRINT "This is GARNET 16 and it occupies 16 screen lines."
FOR de=1 TO 1000:NEXT de
Font "topaz.font", 8,0,0
GOSUB PageTurn
CLS
LINE (0,19)-(615,19),4
Font "Diamond.font", 20,0,0
LOCATE 2,1:COLOR 3,0
PRINT "Diamond 20"
LOCATE 2,8
Font "topaz.font", 8,0,0
PRINT "and Topaz 8 both on the same screen line"
Font "Diamond.font", 20,0,0
LOCATE 2,25
PRINT "Diamond 20"
LINE (0,39)-(615,39),4
Font "topaz.font", 8,0,0
PRINT:PRINT"The lines show the area occupied by the Diamond font."
PRINT
PRINT "This is the command you use to get a DiskFont."
PRINT
COLOR 4,0
PRINT " Font ";CHR$(34);"Diamond.font";CHR$(34);", 20,0,0"
COLOR 1,0
PRINT
PRINT "And this is the command you use to Set the Style."
PRINT
COLOR 4,0
PRINT " enable%=AskSoftStyle&(WINDOW(8))"
PRINT " SetStyle 1"
GOSUB PageTurn
CLS:COLOR 1,0
PRINT "This is the SUB Program which calls a DiskFont."
PRINT:COLOR 4,0
PRINT " SUB Font(fontName$, height%, style%, prefs%) STATIC"
PRINT " SHARED pFont&"
PRINT " IF pFont&<>0 THEN CALL CloseFont(pFont&)"
PRINT " fontName0$=fontName$+CHR$(0)"
PRINT " textAttr&(0)=SADD(fontName0$)"
PRINT " textAttr&(1)=height%*65536& + style%*256 + prefs%"
PRINT " pFont&=OpenDiskFont&(VARPTR(textAttr&(0)))"
PRINT " IF pFont& <> 0 THEN SetFont WINDOW(8),pFont&"
PRINT " END SUB"
PRINT:COLOR 1,0
PRINT "And this SUB Program Sets the Style"
PRINT:COLOR 4,0
PRINT " SUB SetStyle(mask%) STATIC"
PRINT " SHARED enable%"
PRINT " SetSoftStyle WINDOW(8),mask%,enable%"
PRINT " END SUB"
COLOR 1,0
GOSUB PageTurn
CLS
FOR x=7 TO 192 STEP 8
LINE (0,x)-(615,x),1
NEXT x
LOCATE 10,1
COLOR 3,0
PRINT "This is Text Line 10"
PRINT :PRINT "Note the empty Screen line under this TEXT."
SetStyle 1
PRINT "This screen line is used if the SoftStyle underline is used."
SetStyle 0
PRINT "It is also used for the tail of the letters 'y g p q."
PRINT "Because the LINE command was used before the TEXT was PRINTed"
PRINT "the empty line under each letter overwrites the line on the"
PRINT "screen. Now see what happens if the LINE command comes after"
PRINT "the TEXT. Take careful note of the letters 'y g p q'"
GOSUB PageTurn
CLS
LOCATE 10,1
PRINT "This is Text Line 10."
PRINT
PRINT "As you can see the LINES have been drawn in the empty Screen"
PRINT "line at the bottom of each letter."
SetStyle 1
PRINT "Here are the letters Yy Gg Pp Qq."
SetStyle 0
PRINT "The TOPAZ FONT occupies all of the 8 pixels of its Point Size"
PRINT "therefore the line command will overwrite the curly bit at the"
PRINT "bottom of the letter and any underlining that may be there."
PRINT
PRINT
LOCATE 28,15:INPUT "Press RETURN to draw the lines.",dum$
FOR x=7 TO 192 STEP 8
LINE (0,x)-(615,x),1
NEXT x
GOSUB PageTurn
CLS
Font "Diamond.font", 20,0,0
LOCATE 2,1
PRINT "Diamond 20"
FOR x=19 TO 192 STEP 20
LINE (0,x)-(615,x),1
NEXT x
PRINT "This is Diamond again."
PRINT "The LINES are drawn at 20 screen line"
PRINT "Intervals. The top of the letter is"
PRINT "At the very top of its 20 points."
PRINT "More space is left for the 'y g p and q."
GOSUB PageTurn
CLS
LOCATE 2,1
SetStyle 1
PRINT "Diamond 20"
PRINT "This is Diamond again.Now Underlined. The LINES are "
PRINT "drawn at 20 screen line Intervals. The top of the letter is"
PRINT "at the very top of its 20 points. More space is left for the "
PRINT "'y g p and q. The curly bits are overwritten again."
PRINT "But notice where the underlining occurs."
FOR x=19 TO 192 STEP 20
LINE (0,x)-(615,x),1
NEXT x
Font "topaz.font", 8,0,0
GOSUB PageTurn
SetStyle 0
Font "RUBY.font", 15,0,0
CLS
FOR x= 4 TO 640 STEP 5
LINE (x,0)-(x,256),1
NEXT x
FOR Y = 14 TO 256 STEP 15
LINE(0,Y)-(640,Y),1
NEXT Y
LOCATE 2,5: PRINT "A"
LOCATE 2,10:PRINT "a"
LOCATE 4,5:PRINT "B"
LOCATE 4,10:PRINT "b"
SetStyle 3
LOCATE 2,15: PRINT "A"
LOCATE 2,20:PRINT "a"
LOCATE 4,15:PRINT "B"
LOCATE 4,20:PRINT "b"
LOCATE 2,25:PRINT "I"
LOCATE 2,30:PRINT "i"
SetStyle 0
PRINT
PRINT "The Screen is now divided into 5 x 15 Squares. RUBY"
PRINT
PRINT "is a 15 point font. See if you can count how many"
PRINT
PRINT " pixels each letter occupies."
PRINT
Font "topaz.font",8,0,0
PRINT "The Capital letters are fairly wide and the lowercase letters"
PRINT "vary some 10 others less. This is a PROPORTIONAL font."
Font "",0,0,0 'Causes last pFont to be closed
GOSUB PageTurn
Font "topaz.font",11,0,0
CLS
FOR x= 7 TO 640 STEP 8
LINE (x,0)-(x,256),1
NEXT x
FOR Y =10 TO 256 STEP 11
LINE(0,Y)-(640,Y),1
NEXT Y
PRINT
PRINT "This is Topaz 11 and the screen is divided into 8 x 11 pixel rectangles."
PRINT
PRINT "As you can see this, like its little brother topaz 8,is not PROPORTIONAL."
PRINT
PRINT "Every letter occupies the same number of pixels Across (8) and Down (11)."
PRINT
Font "topaz.font", 9,0,0
PRINT "This line is Topaz 9 and it is not the same width as Topaz 11."
PRINT
PRINT "And not as Tall."
PRINT
Font "topaz.font",8,0,0
PRINT "This line is Topaz 8 and it is the same width as Topaz 11."
PRINT
PRINT "But not as Tall as 9."
PRINT
GOSUB PageTurn
ls=1461
DIM CHECK(64)
DIM p%(1461)
MakeLetter:
CLS
PRINT:PRINT "How an Eight Point letter is formed"
x=100:Y=50:box=10
FOR D=0 TO 8
LINE (x,Y+D*box)-(x+80,Y+D*box),3
NEXT D
FOR D=0 TO 8
LINE (x+D*box,Y)-(x+D*box,Y+80),3
NEXT D
LINE (100,50)-(170,60),2,BF
LINE (110,60)-(130,110),2,BF
LINE (100,110)-(140,120),2,BF
LINE (130,80)-(160,90),2,BF
LINE (160,60)-(170,70),2,BF
box=10
nbox=8
size=box*nbox
CL2:
FOR CH=0 TO 64
CHECK(CH)=0
NEXT CH
x=200:Y=50
X2=x+size:Y2=Y+size
FOR D=0 TO nbox
LINE (x,Y+D*box)-(X2,Y+D*box),2
NEXT D
FOR D=0 TO nbox
LINE (x+D*box,Y)-(x+D*box,Y2),2
NEXT D
LINE (400,20)-(450,45),5,b
LINE (400,50)-(450,75),5,b
LINE (500,141)-(380,161),4,b
LOCATE 19,52:PRINT"Clear the"
LOCATE 20,52:PRINT " box"
LOCATE 4,52:PRINT "TRY"
LOCATE 5,52:PRINT "IT"
LOCATE 8,52:PRINT "END"
LOCATE 9,52:PRINT "IT"
LOCATE 24,1:PRINT"The RED box is yours to play with. Click in one of the"
PRINT "squares to fill it in. Click in it again to delete it."
PRINT "Click in the TRY IT box and you will be given the chance to Save"
PRINT "The shape to a file.If you don't wish to save it just press RETURN."
PRINT "Click in the END IT box when you have finished."
FOR C=0 TO 8
WL2:
xx=0
WHILE xx=0
xx=MOUSE(0)
x$="":x$=INKEY$
WEND:WHILE MOUSE(0)<>0:WEND:S=MOUSE(1):T=MOUSE(2)
IF S>400 AND S<450 AND T>20 AND T<45 THEN GOTO SaveLetter
IF S>400 AND S<450 AND T>50 AND T<75 THEN GOTO ENDIT
IF S>400 AND S>141 THEN Z=0: GOTO ClearBox
IF S>=200 AND S<280 AND T>=51 AND T<59 THEN D=0:GOTO PLACE
IF S>=200 AND S<280 AND T>=61 AND T<69 THEN D=1:GOTO PLACE
IF S>=200 AND S<280 AND T>=71 AND T<79 THEN D=2:GOTO PLACE
IF S>=200 AND S<280 AND T>=81 AND T<89 THEN D=3:GOTO PLACE
IF S>=200 AND S<280 AND T>=91 AND T<99 THEN D=4:GOTO PLACE
IF S>=200 AND S<280 AND T>=101 AND T<109 THEN D=5:GOTO PLACE
IF S>=200 AND S<280 AND T>=111 AND T<119 THEN D=6:GOTO PLACE
IF S>=200 AND S<280 AND T>=121 AND T<129 THEN D=7:GOTO PLACE
PLACE:
IF S>=(201) AND S<=(209) AND CHECK((D*8)+1)=0 THEN COL=3:CHECK((D*8)+1)=1:C=0:GOTO LineDraw
IF S>=(211) AND S<=(219) AND CHECK((D*8)+2)=0 THEN COL=3:CHECK((D*8)+2)=1:C=1:GOTO LineDraw
IF S>=(221) AND S<=(229) AND CHECK((D*8)+3)=0 THEN COL=3:CHECK((D*8)+3)=1:C=2:GOTO LineDraw
IF S>=(231) AND S<=(239) AND CHECK((D*8)+4)=0 THEN COL=3:CHECK((D*8)+4)=1:C=3:GOTO LineDraw
IF S>=(241) AND S<=(249) AND CHECK((D*8)+5)=0 THEN COL=3:CHECK((D*8)+5)=1:C=4:GOTO LineDraw
IF S>=(251) AND S<=(259) AND CHECK((D*8)+6)=0 THEN COL=3:CHECK((D*8)+6)=1:C=5:GOTO LineDraw
IF S>=(261) AND S<=(269) AND CHECK((D*8)+7)=0 THEN COL=3:CHECK((D*8)+7)=1:C=6:GOTO LineDraw
IF S>=(271) AND S<=(279) AND CHECK((D*8)+8)=0 THEN COL=3:CHECK((D*8)+8)=1:C=7:GOTO LineDraw
IF S>=(201) AND S<=(209) AND CHECK((D*8)+1)=1 THEN COL=0:CHECK((D*8)+1)=0:C=0:GOTO LineDraw
IF S>=(211) AND S<=(219) AND CHECK((D*8)+2)=1 THEN COL=0:CHECK((D*8)+2)=0:C=1:GOTO LineDraw
IF S>=(221) AND S<=(229) AND CHECK((D*8)+3)=1 THEN COL=0:CHECK((D*8)+3)=0:C=2:GOTO LineDraw
IF S>=(231) AND S<=(239) AND CHECK((D*8)+4)=1 THEN COL=0:CHECK((D*8)+4)=0:C=3:GOTO LineDraw
IF S>=(241) AND S<=(249) AND CHECK((D*8)+5)=1 THEN COL=0:CHECK((D*8)+5)=0:C=4:GOTO LineDraw
IF S>=(251) AND S<=(259) AND CHECK((D*8)+6)=1 THEN COL=0:CHECK((D*8)+6)=0:C=5:GOTO LineDraw
IF S>=(261) AND S<=(269) AND CHECK((D*8)+7)=1 THEN COL=0:CHECK((D*8)+7)=0:C=6:GOTO LineDraw
IF S>=(271) AND S<=(279) AND CHECK((D*8)+8)=1 THEN COL=0:CHECK((D*8)+8)=0:C=7:GOTO LineDraw
LineDraw:
LINE(201+C*10,51+D*10)-(209+C*10,59+D*10),COL,BF
NEXT C
GOTO WL2
ClearBox:
LINE (x,Y)-(x+(box*box),Y+(box*box)),0,BF
GOTO CL2
SaveLetter:
GET (x,Y)-(X2,Y2),p%
COLOR 5,1
INPUT "Do you wish to SAVE the letter to Disk ( [Y]es [N]o )",sd$
IF sd$ = "y" OR sd$ = "Y" THEN
COLOR 6,1
INPUT "Give it a File Name ",FIN$
OPEN FIN$ FOR OUTPUT AS 1
FOR x=0 TO ls
PRINT#1,MKI$(p%(x));
NEXT x
CLOSE 1
END IF
COLOR 3,0
CLS
PRINT "The BINARY values of each line can be found in the contents of the CHECK()"
PRINT
PRINT "And these are:-"
PRINT:v$="":COLOR 4,0
PRINT " BINARY HEX DECIMAL"
COLOR 1,0
FOR Y=0 TO 7
LOCATE 7+Y,10
FOR x=1 TO 8
v$=v$+ RIGHT$(STR$(CHECK((Y*8)+x)),1)
NEXT x
de1=VAL(LEFT$(v$,1))*128
de2=VAL(MID$(v$,2,1))*64
de3=VAL(MID$(v$,3,1))*32
de4=VAL(MID$(v$,4,1))*16
de5=VAL(MID$(v$,5,1))*8
de6=VAL(MID$(v$,6,1))*4
de7=VAL(MID$(v$,7,1))*2
de8=VAL(RIGHT$(v$,1))*1
deci=de1+de2+de3+de4+de5+de6+de7+de8
PRINT v$," = &H"HEX$(deci)," = ";
PRINT USING "###";deci
v$=""
NEXT Y
GOSUB PageTurn
CLS
PutLetter:
CLS
INPUT "Do you want a Letter from Disk ( [Y]es [N]o ). ",gd$
IF gd$ = "y" OR gd$ = "Y" THEN
INPUT "Which File Name ",FIN$
OPEN FIN$ FOR INPUT AS 1
FOR x = 0 TO ls
p%(x) = CVI(INPUT$(2,1))
NEXT x
CLOSE 1
END IF
CLS
PALETTE 2,0,0,0
FOR x=1 TO 5
PUT (x*100,40),p%
NEXT x
GOSUB PageTurn
PALETTE 2,.5,0,0
GOTO MakeLetter
ENDIT:
CLS
Font "Diamond.Font",20,0,0
LOCATE 5,15:COLOR 7,0
PRINT "The End"
Font "topaz.font",8,0,0
GOSUB PageTurn
WINDOW CLOSE 2
SCREEN CLOSE 1
LIBRARY CLOSE
SYSTEM
PageTurn:
LOCATE 28,15:INPUT "Press RETURN to turn Page ",dum$
RETURN
SUB Font(fontName$, height%, style%, prefs%) STATIC
SHARED pfont&
IF pfont&<>0 THEN CALL CloseFont(pfont&)
fontName0$=fontName$+CHR$(0)
textAttr&(0)=SADD(fontName0$)
textAttr&(1)=height%*65536& + style%*256 + prefs%
pfont&=OpenDiskFont&(VARPTR(textAttr&(0)))
IF pfont& <> 0 THEN SetFont WINDOW(8),pfont&
END SUB
SUB SetStyle(mask%) STATIC
SHARED enable%
SetSoftStyle WINDOW(8),mask%,enable%
END SUB